home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / TECHNICA / AUTOCAD / 3824.ZIP / ELF110.ZIP / DEMO.LSP next >
Text File  |  1993-02-21  |  18KB  |  501 lines
  1. ;;; DEMO.LSP
  2. ;;; Copyright 1992 by Mountain Software
  3. ;;;
  4. ;;; This program requires ELF, the Extended Lisp Function library
  5. ;;;
  6. ;;; THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
  7. ;;; WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
  8. ;;; PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.
  9. ;;;
  10. ;;;*===================================================================*
  11. ;;;
  12. ;;; Demo.Lsp is a demonstration of the capabilities of the ELF
  13. ;;; library. Demo exercises many (but not all) ELF functions and
  14. ;;; commands and illustrates how the functions can be utilized.
  15. ;;; It also provides AutoLISP programmers with sample code that
  16. ;;; can included in their own programs.
  17.  
  18. (Princ "\nLoading Demo.Lsp")
  19. (Load"ELF")
  20.  
  21. ;;;*----- The ELF Demo
  22.  
  23. (DeFun C:DEMO( / mstr mfun i attr done video vcols vrows ans key helplst)
  24.   (SetQ mstr   '("Introduction" "Window System" "Video Functions"
  25.                  "Data Entry Form" "String Functions" "Math Functions"
  26.                  "Directory Demo" "File Functions" "Low Level Functions"
  27.                  "Look at an ASCII file" "Function List" "ELF Apps" "Quit")
  28.     mfun   '(intro wdemo scrdemo edemo strdemo mdemo ddemo
  29.                  fdemo ldemo look_demo (list () '(Set_Color 23) '(c:elf))
  30.                  apps_demo (list () '(SetQ done T)))
  31.         bcolor (| white lgrey_bg)
  32.         logo    "▒▒▒▒░▒░░░░▒▒▒▒\n▒░░░░▒░░░░▒░░░\n▒▒▒▒░▒░░░░▒▒▒▒\n▒░░░░▒░░░░▒░░░\n▒▒▒▒░▒▒▒▒░▒░░░"
  33.         old_error *error*
  34.         *error*   DemoError
  35.         helplst (list "[ ELF Demo Help ]" ""
  36.                       "Select one of the Menu Items or press <Esc> to Quit" ""
  37.                       "This is a Demonstration of ELF"
  38.                       "The Extended Lisp Function Library" ""
  39.                       "ELF is available from:" ""
  40.                       (eval name) (eval address)
  41.                       (strcat city ", " state " " zip) ""
  42.                       "Press <F1> for Menu help")
  43.   )
  44.   (TextScr)
  45.   (SetQ attr (| lgrey blue_bg)
  46.         video (Get_Video) vcols (Car video) vrows (Cadr video))
  47.   (Set_Color attr)
  48.   (Scr_Fill 0 1 vcols (- vrows 2) 176 bcolor)
  49.   (GotoXY 0 1)
  50.   (Puts logo bcolor)
  51.   (Scr_Fill 0 0 vcols 1 32 attr)
  52.   (Prts 19 0 "Extended Lisp Function [ELF] library Demo" (| white blue_bg))
  53.   (Scr_Fill 0 (1- vrows) vcols 1 32 attr)
  54.   (Prts 26 (1- vrows) "(c) 1992 Mountain Software" attr)
  55.   (bloop)
  56.   (While (Not done) (Progn
  57.     (Set_menu_help helplst)
  58.     (Wopen -1 -1 27 18 (| white cyan_bg) (| cyan cyan_bg) (| no_bd shadow_bd))
  59.     (Wputcen "ELF Demo Menu")
  60.     (WgotoXY 0 1)
  61.     (Wputcen "Select" (| lcyan cyan_bg))
  62.     (SetQ ans (Wmenu mstr -1 6 (| white cyan_bg) (| black cyan_bg)
  63.                      (| white black_bg) (| single_bd tlhl_bd))
  64.           key (Cadr ans)
  65.           i   (Car ans))
  66.     (Wclose)
  67.     (Save_Screen)
  68.     (If(= key Esc_Key)
  69.       (SetQ done T)
  70.     ;else
  71.       (Eval(List(nth i mfun)))         ;Execute the selected function
  72.     )
  73.     (TextScr)
  74.     (Restore_Screen)
  75.   ))
  76.   (WcloseAll)
  77.   (SetQ *error* old_error)
  78.   (Cls 7)
  79. )
  80.  
  81. ;;;*----- Introduction
  82.  
  83. (DeFun INTRO()
  84.   (Wmenu '("ELF is a library of over 190 new functions for"
  85.            "AutoLISP.  In addition, ELF also adds 17 file"
  86.            "management and utility commands to AutoCAD. The"
  87.            "library and commands are contained in a single"
  88.            "EXP file, and expands AutoLISP into a \"rich\""
  89.            "programming language. The range of functions"
  90.            "include video and text window extentions, math"
  91.            "and string handling, file and directory, list"
  92.            "handling, keyboard, sound, and utility routines."
  93.            "During this demonstration you may press <F1> for"
  94.            "online help and <Esc> to exit or quit.")
  95.            -1 -1 23 31 31 (| 5 32))
  96. )
  97.  
  98. ;;;*----- ELF Apps
  99.  
  100. (DeFun APPS_DEMO( / mstr flst rslt fname key i)
  101.   (Setq mstr '("ELF Notepad - an ASCII editor in AutoLISP"
  102.                "eTables     - view Block, Layer, etc tables"
  103.                "SelSet      - selection set manipulation"
  104.                "Template    - a generic ELF application")
  105.         flst '("notepad" "etables" "selset" "template")
  106.         rslt (Wmenu mstr))
  107.   (Cls 7)
  108.   (If(/= (Cadr rslt) Esc_Key)
  109.     (run (Nth (Car rslt) flst)))
  110. )
  111.  
  112. ;;;*----- Load and run an AutoLISP file
  113.  
  114. (Defun RUN(funcname / func filename)
  115.   (SetQ func     (Read(Strcat "C:" funcname))
  116.         filename (Strcat funcname ".LSP"))
  117.  
  118. ;*-----Load the function if not already loaded
  119.  
  120.   (If(Not(Cadr(Eval Func)))
  121.     (If(Findfile filename)
  122.       (Load funcname)
  123.    ;else
  124.       (Wmsg(Strcat "\nError: " filename "\nis not on the AutoCAD library path."))
  125.     )
  126.   )
  127.  
  128. ;*----- Execute the function if it exists
  129.  
  130.   (if(= (Type (Eval func)) 'LIST)
  131.     (Eval(list func))
  132.   ;else
  133.     (Wmsg(Strcat "\nError: " funcname "\nis not a valid AutoLISP function"))
  134.   )
  135.   (princ)
  136. )
  137.  
  138. (SetQ contact "Jerry Workman"
  139.       name    "Mountain Software"
  140.       address "1579 Nottingham Road"
  141.       city    "Charleston"
  142.       state   "WV"
  143.       zip     "25304-2453"
  144. )
  145.  
  146. ;;;*-----Data Entry Demo
  147.  
  148. (DeFun EDEMO( / fields tcolor dcolor)
  149.   (SetQ tcolor (| dgrey lgrey_bg)
  150.         dcolor (| white lgrey_bg)
  151.         wcolor (| black lgrey_bg))
  152.  
  153. ;;;*=========================================================*
  154. ;;;*              Data Entry Form Layout                     *
  155. ;;;*=============col=row=prompt=========col=row=symbol==width*
  156.   (SetQ fields '((1  1   "Contact"       15 1   contact 40)
  157.                  (1  3   "Company Name"  15 3   name    40)
  158.                  (1  5   "Address"       15 5   address 40)
  159.                  (1  7   "City"          15 7   city    15)
  160.                  (33 7   "State"         40 7   state    2)
  161.                  (43 7   "ZIP"           47 7   zip     10)))
  162.  
  163.   (Wopen 0 0 vcols vrows 7 7 0)         ;open a window to cover the screen
  164.   (Wpopup 68 15 dcolor dcolor 0)        ;and another for the background
  165.   (Wtitle "Data entry form" 1 wcolor)
  166.   (Wtitle "<Ctrl><Enter> - done" 3 wcolor)
  167.   (Wtitle "<F1> - help" 5 wcolor)
  168.   (Wpopup 64 13 wcolor wcolor 10)       ;two more nested windows to make the
  169.   (Wpopup 60 11 wcolor wcolor 18)       ;raised border effect
  170.   (getdata fields tcolor dcolor)        ;process the form
  171.   (WcloseAll)
  172. )
  173.  
  174. ;;;*----- Process the Data Entry form
  175.  
  176. (DeFun GETDATA(template pcolor dcolor / done fld i key rslt &symbol)
  177.   (SetQ cnt (Length template) i 0)
  178.   (Repeat cnt                          ;;; display form
  179.     (SetQ fld   (Nth i template)
  180.           i     (1+ i))
  181.     (Wprts (Car fld) (Cadr fld) (Caddr fld) pcolor)
  182.     (Wprts (Nth 3 fld) (Nth 4 fld) (Eval(Nth 5 fld)) dcolor)
  183.   )
  184.   (SetQ i 0 done nil)
  185.   (While (Not done) (Progn
  186.     (SetQ fld     (Nth i template)
  187.           rslt    (getitem fld dcolor)
  188.           &symbol (Nth 5 fld)               ;;; pointer to variable
  189.           key     (Cadr rslt)
  190.     )
  191.     (Set  &symbol (Car rslt))               ;;; assign string to variable
  192.   (Cond
  193.     ((= key Esc_Key)   (SetQ done T))       ;;; escape pressed, quit
  194.     ((= key C_Ent_Key) (SetQ done T))       ;;; <Ctrl>Enter
  195.     ((= key Up_Key)    (SetQ i (up1 cnt)))  ;;; up arrow
  196.     (T (SetQ i (Rem (1+ i) cnt))))
  197.   ))
  198. )
  199.  
  200. ;;;*----- Move back one field
  201.  
  202. (DeFun UP1(cnt)                         ;;; guarantees no negative values
  203.   (Rem (1- (+ cnt i)) cnt)
  204. )
  205.  
  206. ;;;*----- Fetch the String
  207.  
  208. (DeFun GETITEM(fld dcolor)
  209.     (WgotoXY (Nth 3 fld) (Nth 4 fld))
  210.     (StrGet (Eval (Nth 5 fld)) (Nth 6 fld) 0 "▒" dcolor)
  211. )
  212.  
  213. ;;;*----- Screen Demo
  214.  
  215. (DeFun SCRDEMO()
  216.   (Scr_Fill 0 0 vcols vrows 178 (| blue lgrey_bg))
  217.   (Wmsg (StrCat "(Scr_Fill) fills areas of the screen,"
  218.                 "\n(Save_Screen) takes a snapshot of the screen,"
  219.                 "\n(Restore_Screen) restores the snapshot,"
  220.                 "\nand (CLS) clears the screen. We will cycle"
  221.         "\n100 screen redraws now.") 1 (| white brown_bg))
  222.   (Repeat 100
  223.     (Restore_Screen)
  224.     (Save_Screen)
  225.     (CLS 7)
  226.   )
  227.   (Repeat 1000
  228.     (Prts (Fix(Rem (Rand) (- vcols 15))) (Fix(Rem (Rand) (1- vrows))) "Hello World" (Fix(Rem (Rand) 90)))
  229.   )
  230.   (Wmsg "1000 Strings using (Prts)\n(The hiccup was from AutoLISP)" 1 (| white red_bg) (| black red_bg))
  231. )
  232.  
  233. ;;;*----- Directory Demo
  234.  
  235. (DeFun DDEMO( / dstat drive_no drive_str sector cluster
  236.                 drive_bytes free_bytes)
  237.   (SetQ   dstat       (GetDiskFree 0)
  238.           drive_no    (GetDisk)
  239.           drive_str   (Chr(+ drive_no (1-(ASCII "A"))))
  240.           sector      (Cadddr dstat)
  241.           cluster     (* sector (Caddr dstat))
  242.           drive_bytes (* cluster (Car dstat))
  243.           free_bytes  (* cluster (Cadr dstat))
  244.   )
  245.   (Wopen 0 0 vcols vrows attr attr 4)
  246.   (Wtitle "Directory" 1)
  247.   (Wprintf "\n(GetDir) returns\n\t%s" (GetDir))
  248.   (Wprintf "\n(GetDisk) returns\n\t%d or drive %s:" drive_no drive_str)
  249.   (Wprintf "\n\n(GetDiskFree 0) returns:\n\t(%.0f %.0f %d %d)"
  250.                 drive_bytes free_bytes sector cluster)
  251.   (Wprintf "\nThe current drive has the following stats:")
  252.   (Wprintf "\n\tsector size: %d, cluster size: %d " sector cluster)
  253.   (Wprintf "\n\tTotal bytes: %.0f, Free bytes: %.0f " drive_bytes free_bytes)
  254.   (wpause)
  255.   (Wopen 2 7 40 8 32 32 (| 1 8))
  256.   (Wputs "\n (WgetFile) Gets a filename...")
  257.   (Wputs "\n\n  Press <AltD> to Select\n  another Disk Drive")
  258.   (Wmsg (WgetFile "*.*" 33 50 -1 (| white cyan_bg)))
  259.   (Wclose)
  260. )
  261.  
  262. ;;;*----- File system Demo
  263.  
  264. (DeFun FDEMO( / filename fl)
  265.   (SetQ filename    (FindFile "ACAD.PGP")
  266.         fl          (SplitPath filename)
  267.   )
  268.   (Wopen 0 0 vcols vrows attr attr 3)
  269.   (Wtitle "File Demo" 1)
  270.   (Wprintf "\n\n(CopyFile \"C:\\CONFIG.SYS\" \".\")")
  271.     (CopyFile "C:\\CONFIG.SYS" ".")
  272.   (Wprintf "\n(MkDir \"&TEMP&\")")
  273.     (MkDir "&TEMP&")
  274.   (Wprintf "\n(MoveFile \"CONFIG.SYS\" \"&TEMP&\")")
  275.     (MoveFile "CONFIG.SYS" "&TEMP&")
  276.   (Wprintf "\n\n(FullPath \"&TEMP&\\CONFIG.SYS\") returns\n%s"
  277.     (FullPath "&TEMP&\\CONFIG.SYS"))
  278.   (Wprintf "\n\n(EraseFile \"&TEMP&\\CONFIG.SYS\")")
  279.     (EraseFile "&TEMP&\\CONFIG.SYS")
  280.   (Wprintf "\n(RmDir \"&TEMP&\")")
  281.     (RmDir "&TEMP&")
  282.   (wpause)
  283.   (Wprintf "\n\n(SplitPath %s) returns\n\t" filename)
  284.   (Wprintf "\nDrive:     \"%s\"" (Car fl))
  285.   (Wprintf "\nDirectory: \"%s\"" (Cadr fl))
  286.   (Wprintf "\nName:      \"%s\"" (Caddr fl))
  287.   (Wprintf "\nExt:       \"%s\"" (Cadddr fl))
  288.   (wpause)
  289.   (Wclose)
  290. )
  291.  
  292. (DeFun BLOOP()
  293.   (Beep 1600 0.1)
  294.   (Beep 800 0.1)
  295.   (Beep 1600 0.1)
  296. )
  297.  
  298. ;;;*----- Play Charge
  299.  
  300. (DeFun CHARGE( / c f a c2)
  301.   (SetQ c 262 f 349 a 440 c2 523)
  302.   (Beep c 0.1)
  303.   (Beep f 0.1)
  304.   (Beep a 0.1)
  305.   (Beep c2 0.2)
  306.   (Beep a 0.1)
  307.   (Beep c2 0.3)
  308. )
  309.  
  310. ;;;*----- Low Level Function Demo
  311.  
  312. (DeFun LDEMO()
  313.   (Wopen 0 0 vcols vrows attr attr 3)
  314.   (Wtitle "Low Level Functions" 1)
  315.   (Wprintf "\nbeeping the speaker...") (Beep) (Wait 0.5)
  316.   (Wprintf "\nand custom sounds...\n") (charge)
  317.   (Wprintf "\nThe current time is:\n\t%s on %s\n" (StrTime) (StrDate))
  318.   (Wprintf "\nPress any letter key to test (GetKey)...")  (SetQ key (GetKey))
  319.   (Wprintf "(GetKey) returns \%d\) or \"%s\"" key (Chr(LoByte key)))
  320.   (Wprintf "\n\n(Key_Ready) returns immediately with any waiting keystroke")
  321.   (Wprintf "\n(KbHit) checks for a waiting keystroke")
  322.   (Wprintf "\n\teg (While(Not(KbHit)) (long_loop_process))")
  323.   (Wprintf "\n\n(Key_Stuff) inserts keystrokes in the keyboard buffer")
  324.   (Wprintf "\n(Key_Clear) removes any pending keystrokes")
  325.   (Wprintf "\n(Key_Stat) returns the status of control keys (Ctrl/Alt/Shift)")
  326.   (wpause)
  327.   (Wclose)
  328. )
  329.  
  330. ;;;*----- Math Demo
  331.  
  332. (DeFun MDEMO( / radians val1 val2)
  333.   (SetQ val1 123.456 val2 0.5)
  334.   (Wopen 0 0 vcols vrows attr attr 5)
  335.   (Wtitle "Math Functions" 1)
  336.   (SRand)
  337.   (Wprintf "\n\nrandom numbers:\n") (Repeat 5 (Wprintf "%.0f " (Rand)))
  338.   (Wprintf "\n\nDegrees to Radians conversion:\n\t%f degrees is %f radians"
  339.           val1 (SetQ radians (DtR val1)))
  340.   (Wprintf "\nRadians to Degrees conversion:\n\t%f radians is %f degrees"
  341.           radians (RtD radians))
  342.   (Wprintf "\nTrig Functions:")
  343.   (Wprintf "\n\t(Tan  %f) returns %f" val2 (Tan radians))
  344.   (Wprintf "\n\t(Acos %f) returns %f" val2 (Acos val2))
  345.   (Wprintf "\n\t(Asin %f) returns %f" val2 (Asin val2))
  346.   (Wprintf "\n\t(SinH %f) returns %f" val2 (SinH val2))
  347.   (Wprintf "\nAnd...")
  348.   (Wprintf "\n\t(Round %f 1) returns %f" radians (Round radians 1))
  349.   (Wprintf "\n\t(Floor %f) returns %f" radians (Floor radians))
  350.   (Wprintf "\n\t(Ceil  %f) returns %f" radians (Ceil radians))
  351.   (Wpause)
  352.   (Wclose)
  353. )
  354.  
  355. ;;;*----- String Demo
  356.  
  357. (DeFun STRDEMO( / str1 str2 str3 str4 ulist slist fmt real1 int1)
  358.   (SetQ str1        "AAA;BBB;CCC"
  359.         str2        "    Hello    World    "
  360.         str3        "Th;is: is /a; test"
  361.         str4        ";:/"
  362.         ulist       '("ZZZ" "SSS" "AAA")
  363.         slist       (Qsort ulist)
  364.         fmt         "%8.3g %4Xh"
  365.         pos         2
  366.         real1       1.23456
  367.         int1        4321
  368.   )
  369.   (Wopen 0 0 vcols vrows attr attr 3)
  370.   (Wtitle "String / List Demo" 1)
  371.   (Wprintf "\n\n(Sprintf \"%s\" %f %d) returns\n\t\"%s\"" fmt real1 int1 (Sprintf fmt real1 int1))
  372.   (Wprintf "\n\n(StrDela \"%s\" \"%s\") returns\n\t\"%s\"" str3 str4 (StrDela str3 str4))
  373.   (Wprintf "\n(StrTrimL \"%s\") returns\n\t\"%s\"" str2 (StrTrimL str2))
  374.   (Wprintf "\n(StrTrimR \"%s\") returns\n\t\"%s\"" str2 (StrTrimR str2))
  375.   (Wprintf "\n(StrTrim \"%s\") returns\n\t\"%s\"" str2 (StrTrim  str2))
  376.   (Wprintf "\n(StrRev \"%s\") returns\n\t\"%s\"" str1 (StrRev str1))
  377.   (Wprintf "\n(Field \"%s\" \";\" 2) returns\n\t\"%s\"" str1 (Field str1 ";" 2))
  378.   (Wprintf "\n(Qsort \'\(\"%s\" \"%s\" \"%s\"\)) returns\n\t\(\"%s\" \"%s\" \"%s\"\)" (Car ulist)(Cadr ulist)(Caddr ulist)
  379.         (Car slist)(Cadr slist)(Caddr slist))
  380.   (Wprintf "\n(Insert \'\(\(\"%s\" \"%s\" \"%s\"\) %d \"%s\"\)) returns\n\t\(\"%s\" \"%s\" \"%s\" \"%s\"\)"
  381.         (Car ulist)(Cadr ulist)(Caddr ulist) pos str1
  382.         (Car (setq slist (Insert slist pos str1)))(Cadr slist)(Caddr slist)(nth 3 slist))
  383.   (Wpause)
  384.   (Wclose)
  385. )
  386.  
  387. ;;;*----- Window Demo
  388.  
  389. (DeFun WDEMO( / str edit_help cols rows)
  390.   (Scr_Fill 0 0 vcols vrows 178 (| lgrey blue_bg))
  391.   (Set_Color (SetQ attr (| white blue_bg)))
  392.   (Setq cols 4 rows 4)
  393.   (Set_Cursor 32 0)                     ; cursor off
  394.   (While (Or(< cols Vcols)(< rows Vrows)) (progn
  395.     (Setq cols (Min(+ cols 4) Vcols) rows (Min(+ rows 2) Vrows))
  396.     (Wpopup cols rows attr attr 1)
  397.   ))
  398.   (Wopen 2 2 35 6 (| black cyan_bg) (| yellow cyan_bg) hdouble_bd)
  399.   (Wtitle "Hidden Window")
  400.   (Wgotoxy 0 3) (Wputcen "This was is hidden")
  401.   (Wopen 4 4 35 8 (| dgrey lgrey_bg) (| black lgrey_bg) no_bd)
  402.   (Wtitle "Multiple Overlapping Windows")
  403.   (Wputcen "with cursor positioning," (| blue lgrey_bg))
  404.   (Wait 0.5)  (WgotoXY 0 2)
  405.   (Wputcen "window write functions," (| red lgrey_bg))
  406.   (WgotoXY 0 4)
  407.   (Wputcen "full color, shadows and" (| black lgrey_bg))
  408.   (WgotoXY 0 5)
  409.   (Wputcen "cursor control" (| black lgrey_bg))
  410.   (Wait 0.5) (Set_Cursor 12 13)            ; cursor on
  411.   (Wshadow)  (Waiting)    (Wclose)
  412.   (Wopen 2 16 40 7 (| white brown_bg) (| yellow brown_bg) vdouble_bd)
  413.   (Wtitle "[ Editor ]" 1)
  414.   (Wtitle "[ F1 - Help ]" 3) (Wshadow)
  415.   (Wputcen "Using (getstr) to get input:")
  416.   (Wputs "\n\nEdit this string: " (| yellow brown_bg))
  417.   (Set_Edit_Help
  418.     '("(StrGet) Function" ""
  419.       "This is user defined help for the line editor (StrGet)" ""
  420.       "It is defined by the function \"(Set_Edit_Help)\" and"
  421.       "the symbol \"edit_help\" in release 12 and higher."))
  422.   (SetQ str (Car(StrGet "ELF demo" 20 0 "▒" (| black lgrey_bg))))
  423.   (Wputs "\nYou entered: ") (Wputs str (| black red_bg))
  424.   (SetQ str "Mountain Software"
  425.     str (WgetStr "using (WgetStr)" str 40 (| yellow black_bg)(| white black_bg)))
  426.   (Wmsg (StrCat "Wmsg Displays a Message\nYou entered " str) 1 (| black lgrey_bg))
  427.   (WcloseAll)
  428.   (Wmsg (StrCat "The Window System contains\nfunctions for text window"
  429.                 "\nhandling, menus, screen painting\n"
  430.         "with complete color and cursor\ncontrol") 1 (| white red_bg))
  431.   (Set_Color (SetQ attr (| lgrey blue_bg)))
  432.   (Wcloseall)
  433. )
  434.  
  435. (DeFun WAITING()
  436.   (Wtitle "Delaying 2 second..." 4 (| blink white red_bg))
  437.   (Wait 2.0)
  438. )
  439.  
  440. (DeFun LOOK_DEMO( / key dat i col)
  441.   (Wopen 0 0 vcols vrows 48 48 0)
  442.   (Set_Color 23)                        ;;; look will use this color
  443.   (Wopen 2 -1 19 5 23 23 5)
  444.   (Wputs "\n Select a file")
  445.   (While (SetQ fn (WgetFile))
  446.     (If fn (Progn
  447.       (Save_Screen)
  448.       (Look fn)
  449.       (Restore_Screen)
  450.     ))
  451.   )
  452.   (Wclose)
  453.   (Wclose)
  454. )
  455.  
  456. (DeFun WPAUSE()
  457.   (Wputs "\n\npress any key...")
  458.   (GetKey)
  459. )
  460.  
  461. (DeFun C:TIMETEST( / a)
  462.   (timeit '(List () (Line '(0.0 0.0) '(1.0 1.0))) 1000)
  463.   (Pause)
  464.   (timeit '(List () (Command "line" "0,0" "1,1" "")) 1000)
  465. )
  466.  
  467. (DeFun TIMEIT(func times / start stop)
  468.   (printf "\n\nTiming %d executions of function " times) (Princ func)
  469.   (printf "\nClock start at %.2f (%s)" (SetQ start (Clock)) (StrTime))
  470.   (Repeat times (Eval func))
  471.   (SetQ stop (Clock))
  472.   (printf "\n%s" func)
  473.   (printf " finished...\nClock stop at %.2f, elapsed time is %.2f seconds"
  474.      stop (SetQ seconds (Abs(- stop start))))
  475.   (printf "\nor %f seconds per iteration" (/ seconds times))
  476.   (Princ)
  477. )
  478.  
  479. (DeFun C:TOP10( / t10 ans key)
  480.   (SetQ t10 '("ZOOM W" "ZOOM P" "LINE" "ARC" "CIRCLE"
  481.               "ERASE" "PLINE" "PEDIT" "TRIM" "BREAK"))
  482.   (SetQ ans (Wmenu t10 -1 -1 (| white red_bg)))
  483.    (If(/= (Cadr ans) Esc_Key)
  484.      (Key_Stuff (StrCat(Nth (Car ans) t10)"\n")))
  485. )
  486.  
  487. (DeFun DemoError(s)
  488.   (Beep)
  489.   (Wmsg (Strcat "Demo ERROR\n" s) 1 (| white red_bg))
  490.   (WcloseAll)
  491.   (Cls 7)
  492.   (SetQ *error* old_error old_error nil)
  493.   (Princ)
  494. )
  495.  
  496. (Princ "\nDEMO.LSP loaded, enter \"DEMO\" to run...")
  497. (Princ)
  498.  
  499. ;;;*----- End of Demo.Lsp
  500.  
  501.